home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / XLISP 2.0 / XLISP Tools / Utility (UL) / BTREE.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1988-04-07  |  2.0 KB  |  54 lines  |  [TEXT/ttxt]
  1. ;; Larry Mulcahy 1988
  2. ;; b-tree
  3.  
  4. (provide 'b-tree)
  5. (require 'structure "structur")
  6. (require 'sequence)
  7. (require 'math)
  8.  
  9. (defstruct b-tree
  10.   value
  11.   (count 0)
  12.   left
  13.   right)
  14.  
  15. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16. ; add-to-b-tree 
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18.  
  19. (defun add-to-b-tree (value tree
  20.                       &key (less-than-predicate #'string<)
  21.                            (equal-predicate #'string=))
  22.   (if (b-tree-value tree)
  23.       (if (funcall equal-predicate value (b-tree-value tree))
  24.           (let ((result (copy-b-tree tree)))    ; increase count
  25.                (incf (b-tree-count result))    ; of value already
  26.                result)                    ; in the tree
  27.           (let ((result (copy-b-tree tree)))
  28.                (if (funcall less-than-predicate value (b-tree-value tree))
  29.                    (let ((new-left 
  30.                            (if (b-tree-left tree)           
  31.                                (add-to-b-tree value (b-tree-left tree))
  32.                                (make-b-tree :value value :count 1))))
  33.                         (setf (b-tree-left result) new-left)
  34.                         result)
  35.                    (let ((new-right 
  36.                            (if (b-tree-right tree)           
  37.                                (add-to-b-tree value (b-tree-right tree))
  38.                                (make-b-tree :value value :count 1))))
  39.                         (setf (b-tree-right result) new-right)
  40.                         result))))
  41.       (make-b-tree :value value :count 1)))    ; new, empty tree
  42.  
  43. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44. ; collect-b-tree-values 
  45. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  46.  
  47. (defun collect-b-tree-values (tree)
  48.   (if (b-tree-value tree)
  49.       (let ((l (b-tree-left tree))
  50.             (r (b-tree-right tree)))
  51.         (concatenate 'list (if l (collect-b-tree-values l))
  52.                            (list (b-tree-value tree))
  53.                            (if r (collect-b-tree-values r))))))
  54.